home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / reference.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  4KB  |  183 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.  
  9.     reference.c
  10.  
  11.     Reference in Constants and Variables
  12. */
  13.  
  14. #include "include.h"
  15.  
  16. Lfboundp()
  17. {
  18.     object sym;
  19.  
  20.     check_arg(1);
  21.     sym = vs_base[0];
  22.     if (type_of(sym) != t_symbol)
  23.         not_a_symbol(sym);
  24.     if (sym->s.s_sfdef != NOT_SPECIAL)
  25.         vs_base[0] = Ct;
  26.     else if (sym->s.s_gfdef == OBJNULL)
  27.         vs_base[0]= Cnil;
  28.     else
  29.         vs_base[0]= Ct;
  30. }
  31.  
  32. object
  33. symbol_function(sym)
  34. object sym;
  35. {
  36. /*
  37.     if (type_of(sym) != t_symbol)
  38.         not_a_symbol(sym);
  39. */
  40.     if (sym->s.s_sfdef != NOT_SPECIAL || sym->s.s_mflag)
  41.         FEinvalid_function(sym);
  42.     if (sym->s.s_gfdef == OBJNULL)
  43.         FEundefined_function(sym);
  44.     return(sym->s.s_gfdef);
  45. }
  46.  
  47. /*
  48.     Symbol-function returns
  49.                 function-closure        for function
  50.         (macro . function-closure)    for macros
  51.         (special . address)        for special forms.
  52. */
  53. Lsymbol_function()
  54. {
  55.     object sym;
  56.  
  57.     check_arg(1);
  58.     sym = vs_base[0];
  59.     if (type_of(sym) != t_symbol)
  60.         not_a_symbol(sym);
  61.     if (sym->s.s_sfdef != NOT_SPECIAL) {
  62.         vs_push(make_fixnum((int)(sym->s.s_sfdef)));
  63.         vs_base[0] = Sspecial;
  64.         stack_cons();
  65.         return;
  66.     }
  67.     if (sym->s.s_gfdef==OBJNULL)
  68.         FEundefined_function(sym);
  69.     if (sym->s.s_mflag) {
  70.         vs_push(sym->s.s_gfdef);
  71.         vs_base[0] = Smacro;
  72.         stack_cons();
  73.         return;
  74.     }
  75.     vs_base[0] = sym->s.s_gfdef;
  76. }
  77.  
  78. Fquote(form)
  79. object form;
  80. {
  81.     if (endp(form))
  82.         FEtoo_few_argumentsF(form);
  83.     if (!endp(MMcdr(form)))
  84.         FEtoo_many_argumentsF(form);
  85.     vs_base = vs_top;
  86.     vs_push(MMcar(form));
  87. }
  88.  
  89. Ffunction(form)
  90. object form;
  91. {
  92.     object fun;
  93.     object fd;
  94.     if (endp(form))
  95.         FEtoo_few_argumentsF(form);
  96.     if (!endp(MMcdr(form)))
  97.         FEtoo_many_argumentsF(form);
  98.     fun = MMcar(form);
  99.     if (type_of(fun) == t_symbol) {
  100.         fd = lex_fd_sch(fun);
  101.         if (MMnull(fd) || MMcadr(fd) != Sfunction)
  102.             if (fun->s.s_gfdef == OBJNULL || fun->s.s_mflag)
  103.                 FEundefined_function(fun);
  104.             else {
  105.                 vs_base = vs_top;
  106.                 vs_push(fun->s.s_gfdef);
  107.             }
  108.         else {
  109.             vs_base = vs_top;
  110.             vs_push(MMcaddr(fd));
  111.         }
  112.     } else if (type_of(fun) == t_cons && MMcar(fun) == Slambda) {
  113.         vs_base = vs_top;
  114.         vs_push(MMcdr(fun));
  115.         vs_base[0] = MMcons(lex_env[2], vs_base[0]);
  116.         vs_base[0] = MMcons(lex_env[1], vs_base[0]);
  117.         vs_base[0] = MMcons(lex_env[0], vs_base[0]);
  118.         vs_base[0] = MMcons(Slambda_closure, vs_base[0]);
  119.     } else
  120.         FEinvalid_function(fun);
  121. }
  122.  
  123. Lsymbol_value()
  124. {
  125.     object sym;
  126.     check_arg(1);
  127.     sym = vs_base[0];
  128.     if (type_of(sym) != t_symbol)
  129.         not_a_symbol(sym);
  130.     if (sym->s.s_dbind == OBJNULL)
  131.         FEunbound_variable(sym);
  132.     else
  133.         vs_base[0] = sym->s.s_dbind;
  134. }
  135.  
  136. Lboundp()
  137. {
  138.     object sym;
  139.     check_arg(1);
  140.     sym=vs_base[0];
  141.     if (type_of(sym) != t_symbol)
  142.         not_a_symbol(sym);
  143.     if (sym->s.s_dbind == OBJNULL)
  144.         vs_base[0] = Cnil;
  145.     else
  146.         vs_base[0] = Ct;
  147. }
  148.  
  149. Lmacro_function()
  150. {
  151.     check_arg(1);
  152.     if (type_of(vs_base[0]) != t_symbol)
  153.         not_a_symbol(vs_base[0]);
  154.     if (vs_base[0]->s.s_gfdef != OBJNULL && vs_base[0]->s.s_mflag)
  155.         vs_base[0] = vs_base[0]->s.s_gfdef;
  156.     else
  157.         vs_base[0] = Cnil;
  158. }
  159.  
  160. Lspecial_form_p()
  161. {
  162.     check_arg(1);
  163.     if (type_of(vs_base[0]) != t_symbol)
  164.         not_a_symbol(vs_base[0]);
  165.     if (vs_base[0]->s.s_sfdef != NOT_SPECIAL)
  166.         vs_base[0] = Ct;
  167.     else
  168.         vs_base[0] = Cnil;
  169. }
  170.  
  171. init_reference()
  172. {
  173.     make_function("SYMBOL-FUNCTION", Lsymbol_function);
  174.     make_function("FBOUNDP", Lfboundp);
  175.     make_special_form("QUOTE", Fquote);
  176.     Sfunction = make_special_form("FUNCTION", Ffunction);
  177.     make_function("SYMBOL-VALUE", Lsymbol_value);
  178.     make_function("BOUNDP", Lboundp);
  179.     make_function("MACRO-FUNCTION", Lmacro_function);
  180.     make_function("SPECIAL-FORM-P", Lspecial_form_p);
  181. }
  182.  
  183.